home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / ODE / obj_array < prev    next >
Encoding:
Text File  |  1991-10-24  |  7.6 KB  |  360 lines
  1. \ Basic Classes of Array.
  2. \
  3. \ Author: Phil Burk
  4. \ Copyright 1986 Delta Research
  5. \
  6. \ MOD: PLB 5/17/91 Split OBJ_ARRAY into OBJ_OBJECT & OBJ_ARRAY
  7. \ 00001 PLB 8/27/91 Fixed }stuff when filling completely.
  8.  
  9. ANEW TASK-OBJ_ARRAY
  10.  
  11.  
  12. \ Support ARRAY classes ----------------------------------
  13. METHOD AT:              METHOD TO:
  14. METHOD NEW:             METHOD LIMIT:
  15. METHOD FREE:            METHOD WIDTH:
  16. METHOD RANGE:           METHOD FILL:
  17. METHOD SIZE:            METHOD USE.DICT:
  18. METHOD DATA.ADDR:       METHOD STUFF:
  19. METHOD INDEXOF:         METHOD +TO:
  20. METHOD SET.WIDTH:       METHOD DO.RANGE:
  21. METHOD EXTEND:          METHOD EMPTY:
  22. METHOD }STUFF:            METHOD MANY:
  23. METHOD ?NEW:
  24.  
  25. U: IF-RANGE-CHECK  ( Use range checking on declared arrays )
  26. TRUE IF-RANGE-CHECK !
  27.  
  28. : RUN.FASTER  ( -- , set flags to NOT error check. )
  29.     false if-range-check !
  30.     false ob-if-check-bind !
  31. ;
  32. : RUN.SAFER  ( -- , set flags to error check. )
  33.     true if-range-check !
  34.     true ob-if-check-bind !
  35. ;
  36.  
  37. \ Byte array definition.
  38. :CLASS OB.BARRAY  <SUPER OBJECT
  39.     IV.SHORT  IV-WIDTH    ( width of cell in bytes )
  40.     IV.LONG  IV-#CELLS   ( elements in array )
  41.     IV.LONG  IV-PNTR     ( pointer to area in extended memory )
  42. \ flag for whether to allocate space from dictionary or heap
  43.     IV.SHORT IV-USE-DICT
  44. \ CFAS for use in basic array access, determine width.
  45.     IV.LONG  IV-AR-CFA-AT
  46.     IV.LONG  IV-AR-CFA-TO
  47.     IV.SHORT IV-RANGE-CHECK?   ( Flag for range checking. )
  48.  
  49. \ Define @ and ! for different array widths.
  50. : AR.@ ( index -- value )
  51.     cell* iv-pntr + @
  52. ;
  53. : AR.W@ ( index -- value )
  54.     2* iv-pntr + w@
  55. ;
  56. : AR.C@ ( index -- value )
  57.     iv-pntr + c@
  58. ;
  59.  
  60. : AR.! ( value index -- )
  61.     cell* iv-pntr + !
  62. ;
  63. : AR.W! ( value index -- )
  64.     2* iv-pntr + w!
  65. ;
  66. : AR.C! ( value index -- )
  67.     iv-pntr + c!
  68. ;
  69.  
  70. : <RANGE:>  ( index -- , make subroutine for speed )
  71.     dup 0 iv-#cells 1- within?
  72.     IF drop ( OK )
  73.     ELSE >newline dup . 0 <
  74.         IF   " Index < 0"
  75.         ELSE " Index out of range"
  76.         THEN " RANGE: ARRAY" swap
  77.         er_fatal ob.report.error  ( does not return )
  78.     THEN
  79. ;
  80.  
  81. :M RANGE: ( index -- , check for index out of range )
  82.     <range:>
  83. ;M
  84.  
  85. \ Define with range checking for debugging and testing.
  86. : AR.RANGE.@ ( index -- value )
  87.     dup <range:>   ar.@
  88. ;
  89. : AR.RANGE.W@ ( index -- value )
  90.     dup <range:>   ar.w@
  91. ;
  92. : AR.RANGE.C@ ( index -- value )
  93.     dup <range:>   ar.c@
  94. ;
  95.  
  96. : AR.RANGE.! ( value index -- )
  97.     dup <range:>   ar.!
  98. ;
  99. : AR.RANGE.W! ( value index -- )
  100.     dup range: self   ar.w!
  101. ;
  102. : AR.RANGE.C! ( value index -- )
  103.     dup range: self   ar.c!
  104. ;
  105.  
  106.  
  107. :M USE.DICT:   ( flag -- , use dictionary for data? )
  108.     iv=> iv-use-dict
  109. ;M
  110.  
  111. :M FREE: ( -- , free memory used for array )
  112.     iv-pntr    iv-use-dict  not
  113.     and IF
  114.         self empty: []   ( late bound empty )
  115.         iv-pntr  mm.free
  116.         0 iv=> iv-pntr  ( mark as unallocated )
  117.         0 iv=> iv-#cells  ( for range checking )
  118.     THEN
  119. ;M
  120.  
  121.  
  122. :M DATA.ADDR: ( -- address_of_allocated_data )
  123.     iv-pntr
  124. ;M
  125.  
  126. :M LIMIT: ( -- #cells , RETURN # ELEMENTS ALLOCATED )
  127.     iv-#cells
  128. ;M
  129.  
  130. :M SIZE:  ( -- #ENTRIES , will be used more for later classes )
  131.     iv-#cells
  132. ;M
  133.  
  134. :M MANY:  ( -- , how many cells are "valid" )
  135.     iv-#cells
  136. ;M
  137.  
  138. \ Fast versions for internal use by methods.
  139. : TO.SELF  ( value index -- , store value in array )
  140.     iv-ar-cfa-to execute
  141. ;
  142. : AT.SELF ( index -- value , fetch value from array )
  143.     iv-ar-cfa-at execute
  144. ;
  145.  
  146. :M TO: ( value index -- , store value in array )
  147.     iv-ar-cfa-to execute
  148. ;M
  149.  
  150. :M AT: ( index -- value , fetch value from array )
  151.     iv-ar-cfa-at execute
  152. ;M
  153.  
  154. : AR.SELECT.CFA  ( Select CFAs based on width and range_check. )
  155.     iv-range-check?
  156.     IF iv-width         ( WITH Range checking )
  157.         CASE
  158.         cell OF 'c ar.range.@ iv=> iv-ar-cfa-at
  159.             'c ar.range.! iv=> iv-ar-cfa-to
  160.         ENDOF
  161.     2    OF 'c ar.range.w@ iv=> iv-ar-cfa-at
  162.         'c ar.range.w! iv=> iv-ar-cfa-to
  163.     ENDOF
  164.     1    OF 'c ar.range.c@ iv=> iv-ar-cfa-at
  165.         'c ar.range.c! iv=> iv-ar-cfa-to
  166.     ENDOF
  167.     " AR.SELECT.RANGE" " Illegal array width!"
  168.     er_fatal ob.report.error
  169.     ENDCASE
  170.     ELSE iv-width         ( NO range checking. )
  171.         CASE
  172.         cell OF 'c ar.@ iv=> iv-ar-cfa-at
  173.             'c ar.! iv=> iv-ar-cfa-to
  174.         ENDOF
  175.     2    OF 'c ar.w@ iv=> iv-ar-cfa-at
  176.         'c ar.w! iv=> iv-ar-cfa-to
  177.     ENDOF
  178.     1    OF 'c ar.c@ iv=> iv-ar-cfa-at
  179.         'c ar.c! iv=> iv-ar-cfa-to
  180.     ENDOF
  181.     " AR.SELECT.RANGE" " Illegal array width!"
  182.     er_fatal ob.report.error
  183.     ENDCASE
  184.     THEN
  185. ;
  186.  
  187. :M DO.RANGE: ( flag -- , Determine whether this array checks range)
  188.     iv=> iv-range-check?
  189.     ar.select.cfa
  190. ;M
  191.  
  192. :M WIDTH: ( -- #bytes , fetch number of bytes per array unit )
  193.     iv-width
  194. ;M
  195.  
  196. :M SET.WIDTH: ( #bytes -- , set number of bytes per array unit )
  197.     iv-pntr  ( is data memory already allocated )
  198.     IF  " SET.WIDTH: OB.ARRAY"
  199.         " Memory already allocated, FREE: first!"
  200.         er_return er.report drop
  201.     ELSE iv=> iv-width   ( set width )
  202.         ar.select.cfa   ( change CFAs )
  203.     THEN
  204. ;M
  205.  
  206. :M ?NEW: ( #cells -- addr | 0 , allocate data space in extended memory )
  207.     ar.select.cfa   ( update CFAs )
  208.     self free: []  ( free any existing data , late bound )
  209.     dup iv=> iv-#cells
  210.     iv-width  *  ( calculate #bytes needed )
  211.     iv-use-dict  IF
  212.         ." Allocating space in dictionary!!"
  213.         here swap allot align
  214.     ELSE
  215.         mm.zalloc?
  216.     THEN
  217.     dup iv=> iv-pntr
  218. ;M
  219.  
  220. : <NEW:ERROR> ( 0 | addr -- ,  ABORT if error )
  221.     0= IF " NEW:" " Not enough memory"
  222.         er_fatal ob.report.error
  223.     THEN
  224. ;
  225.  
  226. :M NEW: ( #cells -- , abort if error )
  227.     ?new: self <new:error>
  228. ;M
  229.  
  230. :M INIT: ( -- , clear data )
  231.     init: super
  232.     0 iv=> iv-#cells
  233.     0 iv=> iv-pntr
  234.     false use.dict: self
  235.     if-range-check @ iv=> iv-range-check? ( do before SET.WIDTH: )
  236.     1 set.width: self   ( 1 byte wide )
  237. ;M
  238.  
  239. :M +TO: ( value index -- , add value to index cell )
  240.     dup at.self rot +
  241.     swap to.self
  242. ;M
  243.  
  244. :M FILL: ( val -- , fill array with value )
  245.     limit: self ?dup
  246.     IF  0 DO
  247.         dup i to.self
  248.     LOOP drop
  249.     ELSE drop " FILL:" " No data space allocated"
  250.         er_return ob.report.error
  251.     THEN
  252. ;M
  253.  
  254. :M CLEAR:  ( -- , zero array )
  255.     0 fill: self
  256. ;M
  257.  
  258. :M EMPTY:  ( -- , just a stub for free: to call )
  259. ;M
  260.  
  261. \ This is klunky is considered obsolete
  262. :M STUFF:  ( vn-1 vn-2 ... v0 N -- , stuff N values into array )
  263.     0 DO
  264.         i self to: []
  265.     LOOP
  266. ;M
  267.  
  268. :M INDEXOF:  (  val  --  [index] flag , search array for )
  269.     0 swap  ( Set false flag. )
  270.     self size: [] ?dup    ( anything in array? )
  271.     IF  ( -- 0 val size )
  272.         0 DO  ( -- 0 val )
  273.             I  at.self over =
  274.             IF  ( -- 0 val , replace false flag )
  275.                 nip I true
  276.                 rot   leave  ( -- i true val )
  277.             THEN
  278.         LOOP
  279.     THEN
  280.     drop  ( val )
  281. ;M
  282.  
  283. :M PRINT: ( -- , print array )
  284.     cr name: self cr
  285.     self  size: [] ?dup
  286.     IF  0 DO
  287.         i dup . self at: [] . cr
  288.         ?pause
  289.     LOOP
  290.     THEN
  291. ;M
  292.  
  293. :M EXTEND: ( #items -- , extend data area )
  294.     iv-pntr
  295.     IF  >r iv-pntr dup ( -- old-memory old-memory )
  296.         iv-#cells iv-width * ( -- om om  old-#bytes )
  297.         r> iv+> iv-#cells    ( update #cells )
  298.         iv-#cells iv-width * mm.alloc ( allocate new area )
  299.         dup iv=> iv-pntr
  300.         swap cmove  ( copy old data to new area )
  301.         mm.free     ( free old ram )
  302.     ELSE new: self
  303.     THEN
  304. ;M
  305.  
  306. variable STUFF{-DEPTH
  307.  
  308. : STUFF{ ( -- , delimit stuff command , save depth )
  309.     depth stuff{-depth !
  310. ;
  311.  
  312. : STUFF.DEPTH  ( -- #items , to stuff )
  313.     depth stuff{-depth @ - 0 max
  314. ;
  315.  
  316. : <}STUFF:>  ( stuff...  --- , load it into object )
  317. \    iv-#cells stuff.depth < ( !!! stuff.depth thrown off by IV-#CELLS )
  318.     stuff.depth iv-#cells >  \ 00001
  319.     IF   stuff.depth self new: []
  320.     ELSE  self clear: []
  321.     THEN
  322. \
  323.     stuff.depth dup stuff{-depth ! dup 0
  324.     DO 1- tuck ( --... t t tn-2 n-1 tn-1 n-1 ) self to: []
  325.     LOOP stuff{-depth !
  326. ;
  327.  
  328. :M }STUFF:  ( stuff...  --- , load it into object )
  329.     <}stuff:>
  330. ;M
  331.  
  332. ;CLASS
  333.  
  334.  
  335. \ Wider ARRAYS -----------------------------------------------
  336.  
  337. :CLASS OB.WARRAY <SUPER OB.BARRAY
  338.  
  339. :M INIT:  ( -- , set to word width  )
  340.     init: super
  341.     2 set.width: self
  342. ;M
  343.  
  344. ;CLASS
  345.  
  346. METHOD EXEC:
  347.  
  348. :CLASS OB.ARRAY <SUPER OB.BARRAY
  349.  
  350. :M INIT:  ( -- , set to cell width )
  351.     init: super
  352.     cell set.width: self
  353. ;M
  354.  
  355. :M EXEC:  ( index -- , execute CFA there )
  356.     at: self   execute
  357. ;M
  358. ;CLASS
  359.  
  360.